home *** CD-ROM | disk | FTP | other *** search
/ Turnbull China Bikeride / Turnbull China Bikeride - Disc 2.iso / STUTTGART / NEWSOFT / AUGUST / WORKDISC / !Forthmacs / spread / algebra next >
Text File  |  1995-10-25  |  3KB  |  100 lines
  1. \ algebraic functions
  2.  
  3. vocabulary algebra
  4.  
  5. algebra also definitions    \ defined in portability layer
  6.  
  7. create op_stack 20 cells allot    \ operator stack for algebraic
  8.                 \ equation compilation
  9.  
  10. \ col_id function assigns n to id at compile time  ( n --)
  11. \ expects row # on tos at run time.
  12. \ subsequent usage of id fetches double value of cell to stack
  13.  
  14. \ 32-bit
  15. : col_id                \ column_id high-level defining word.
  16.     create    ,            \ creates col ids a-z
  17.     does>    @ spcells cell+ @ ;    \ expect a # on the tos and
  18.                     \ pushes the cell value onto 
  19.                                         \ the parameter stack
  20.                     
  21. : assign_id
  22.     col_max 0            \ loop used to assign values to
  23.     do  i col_id  loop ;        \ the alphabetic columns
  24.  
  25. assign_id    a b c d e f g h i j k l m n o p
  26.                  q r s t u v w x y z
  27.  
  28. \ 
  29. \ for example:  1 a  returns the double-int value of cell  1 a
  30. \ 
  31. \ column ids A-Z return values of 0-25 respectively
  32.  
  33. : opp@        ( -- addr )    \ return oprnd stack position
  34.     op_stack dup @ + ;    \ 1st location is stack ptr
  35.  
  36. : >op        \ ( cfa prec -- )
  37.     2 cells op_stack +!
  38.     opp@ 2! ;        \ store cfa and precedence top of oprnd stack
  39.                     
  40. : op>
  41.     opp@ 2@    ( cfa prec )
  42.     2 cells negate op_stack +!    \ pop cfa and prec off oprnd
  43.     drop compile, ;            \ stack and compile into dict.
  44.  
  45. : prec?        \ ( -- prec )
  46.     opp@ @ ;        \ return precedence from top of oprnd stack
  47.  
  48. : ]a                \ end algebraic compilation
  49.     begin    prec?        
  50.     while    op>        \ pop remaining oprnds off stk
  51.     repeat            \ and compile then select forth
  52.     forth ; immediate    \ vocabulary again 
  53.  
  54. \ create high-level definition that performs algebraic
  55. \ compilation.  see text for details of operation
  56.  
  57. : infix
  58.     ' create            \ create new algebraic operator
  59.         swap , , immediate    \ compile cfa of forth operator
  60.     does>   2@            \ and assigned precedence
  61.         begin dup prec? > not    \ at compile time execute if
  62.                     \ prec is lower than oprnd on
  63.         while    >r >r  op>  r> r>
  64.         repeat
  65.         >op ;            \ top of oprnd stack
  66.  
  67. 7 infix * *
  68. 7 infix / /
  69. 6 infix + +
  70. 6 infix - -
  71. 5 infix mod mod
  72.  
  73. : )missing                \ missing ) message
  74.     true abort" missing )" ;    \ if missing then abort
  75.  
  76. : (                    \ left paren
  77.     ['] )missing  1 >op ;        \ prec=1 cfa= )missing message
  78.     immediate            \ push on oprnd stack
  79.  
  80. \ Forth needs to be before algebra in the search order
  81.  
  82. only forth spread also algebra also  forth also
  83. algebra definitions
  84.  
  85. : )
  86.     [ forth ]            \ right paren
  87.     begin    1 prec? <        \ causes all items on oprnd
  88.     while    op>            \ stack to be compiled until
  89.     repeat
  90.     1 prec? =            \ left paren found
  91.     if    2 cells negate op_stack +!    \ left paren should have prec.
  92.     else    true abort" missing ("        \ of 1 else error msg output
  93.     then ;  immediate
  94.  
  95. spread definitions
  96.  
  97. : a[                    \ start algebraic compilation
  98.     op_stack off            \ reset oprnd stack and
  99.     algebra ; immediate        \ select algebra vocabulary
  100.